home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _e532763a7e24e36025eb8d93861e600b < prev    next >
Encoding:
Text File  |  2001-08-20  |  2.1 KB  |  88 lines
  1. #
  2. # Search for our Unix signature in text and binary files
  3. # and replace it with the real prefix ($Config{prefix} by default).
  4. #
  5. package PPM::RelocPerl;
  6. require Exporter;
  7.  
  8. @ISA = qw(Exporter);
  9. @EXPORT = qw(RelocPerl);
  10.  
  11. use File::Find;
  12. use Config;
  13. use strict;
  14.  
  15. # We have to build up this variable, otherwise
  16. # PPM will mash it when it upgrades itself.
  17. my $frompath_default
  18.   = '/tmp' . '/.ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZpErLZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZperl'
  19. ;
  20. my ($topath, $frompath);
  21.  
  22. sub wanted {
  23.     if (-l) {
  24.         return;         # do nothing for symlinks
  25.     }
  26.     elsif (-B) {
  27.         check_for_frompath($_, 1);   # binary file edit
  28.     }
  29.     elsif (-e && -s && -f) {
  30.         check_for_frompath($_, 0);   # text file edit
  31.     }
  32. }
  33.  
  34. sub check_for_frompath {
  35.     my ($file, $binmode) = @_;
  36.     local(*F, $_);
  37.     open(F, "<$file") or die "Can't open `$file': $!";
  38.     binmode F if $binmode;
  39.     while (<F>) {
  40.         if (/\Q$frompath\E/o) {
  41.         close F;
  42.             edit_it($file, $binmode);
  43.             last;
  44.         }
  45.     }
  46.     # implicit close of F;
  47. }
  48.  
  49. sub edit_it
  50. {
  51.     my ($file, $binmode) = @_;
  52.     my $nullpad = length($frompath) - length($topath);
  53.     $nullpad = "\0" x $nullpad;
  54.  
  55.     local $/;
  56.     # Force the file to be writable
  57.     my $mode = (stat($file))[2] & 07777;
  58.     chmod $mode | 0222, $file;
  59.     open(F, "<$file") or die "Couldn't open $file: $!";
  60.     binmode(F) if $binmode;
  61.     my $dat = <F>;
  62.     if ($binmode) {
  63.         $dat =~ s|\Q$frompath\E(.*?)\0|$topath$1$nullpad\0|gs;
  64.     } else {
  65.         $dat =~ s|\Q$frompath\E|$topath|gs;
  66.     }
  67.     close(F) or die "Couldn't close $file: $!";
  68.  
  69.     open(F, ">$file") or die "Couldn't open $file for writing: $!";
  70.     binmode(F) if $binmode;
  71.     
  72.     print F $dat;
  73.     close(F);
  74.     # Restore the permissions
  75.     chmod $mode, $file;
  76. }
  77.  
  78. sub RelocPerl
  79. {
  80.     my ($dir, $opt_topath, $opt_frompath) = @_;
  81.     $topath = defined $opt_topath ? $opt_topath : $Config{'prefix'};
  82.     $frompath = defined $opt_frompath ? $opt_frompath : $frompath_default;
  83.  
  84.     find(\&wanted, $dir);
  85. }
  86.  
  87. 1;
  88.